home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / mailalias.el < prev    next >
Lisp/Scheme  |  1993-06-15  |  7KB  |  189 lines
  1. ;;; mailalias.el --- expand mailing address aliases defined in ~/.mailrc.
  2.  
  3. ;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; Basic functions for defining and expanding mail aliases.
  27. ;; These seal off the interface to the alias-definition parts of a
  28. ;; .mailrc file formatted for BSD's Mail or USL's mailx.
  29.  
  30. ;;; Code:
  31.  
  32. (defvar mail-aliases t
  33.   "Alias of mail address aliases,
  34. or t meaning should be initialized from `~/.mailrc'.")
  35.  
  36. ;; Called from sendmail-send-it, or similar functions,
  37. ;; only if some mail aliases are defined.
  38. (defun expand-mail-aliases (beg end &optional exclude)
  39.   "Expand all mail aliases in suitable header fields found between BEG and END.
  40. Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants.
  41. Optional second arg EXCLUDE may be a regular expression defining text to be
  42. removed from alias expansions."
  43.   (if (eq mail-aliases t)
  44.       (progn (setq mail-aliases nil) (build-mail-aliases)))
  45.   (goto-char beg)
  46.   (setq end (set-marker (make-marker) end))
  47.   (let ((case-fold-search nil))
  48.     (while (let ((case-fold-search t))
  49.          (re-search-forward "^\\(to\\|cc\\|bcc\\|resent-to\\|resent-cc\\|resent-bcc\\):" end t))
  50.       (skip-chars-forward " \t")
  51.       (let ((beg1 (point))
  52.         end1 pos epos seplen
  53.         ;; DISABLED-ALIASES records aliases temporarily disabled
  54.         ;; while we scan text that resulted from expanding those aliases.
  55.         ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
  56.         ;; is where to reenable the alias (expressed as number of chars
  57.         ;; counting from END1).
  58.         (disabled-aliases nil))
  59.     (re-search-forward "^[^ \t]" end 'move)
  60.     (beginning-of-line)
  61.     (skip-chars-backward " \t\n")
  62.     (setq end1 (point-marker))
  63.     (goto-char beg1)
  64.     (while (< (point) end1)
  65.       (setq pos (point))
  66.       ;; Reenable any aliases which were disabled for ranges
  67.       ;; that we have passed out of.
  68.       (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
  69.         (setq disabled-aliases (cdr disabled-aliases)))
  70.       ;; EPOS gets position of end of next name;
  71.       ;; SEPLEN gets length of whitespace&separator that follows it.
  72.       (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t)
  73.           (setq epos (match-beginning 0)
  74.             seplen (- (point) epos))
  75.         (setq epos (marker-position end1) seplen 0))
  76.       (let (translation
  77.         (string (buffer-substring pos epos)))
  78.         (if (and (not (assoc string disabled-aliases))
  79.              (setq translation
  80.                (cdr (assoc string mail-aliases))))
  81.         (progn
  82.           ;; This name is an alias.  Disable it.
  83.           (setq disabled-aliases (cons (cons string (- end1 epos))
  84.                            disabled-aliases))
  85.           ;; Replace the alias with its expansion
  86.           ;; then rescan the expansion for more aliases.
  87.           (goto-char pos)
  88.           (insert translation)
  89.           (if exclude
  90.                (let ((regexp
  91.                  (concat "\\b\\(" exclude "\\)\\b"))
  92.                 (end (point-marker)))
  93.             (goto-char pos)
  94.             (while (re-search-forward regexp end t)
  95.               (replace-match ""))
  96.             (goto-char end)))
  97.           (delete-region (point) (+ (point) (- epos pos)))
  98.           (goto-char pos))
  99.           ;; Name is not an alias.  Skip to start of next name.
  100.           (goto-char epos)
  101.           (forward-char seplen))))
  102.     (set-marker end1 nil)))
  103.     (set-marker end nil)))
  104.  
  105. ;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
  106. (defun build-mail-aliases (&optional file)
  107.   "Read mail aliases from `~/.mailrc' and set `mail-aliases'."
  108.   (setq file (expand-file-name (or file "~/.mailrc")))
  109.   (let ((buffer nil)
  110.     (obuf (current-buffer)))
  111.     (unwind-protect
  112.     (progn
  113.       (setq buffer (generate-new-buffer "mailrc"))
  114.       (buffer-disable-undo buffer)
  115.       (set-buffer buffer)
  116.       (cond ((get-file-buffer file)
  117.          (insert (save-excursion
  118.                (set-buffer (get-file-buffer file))
  119.                (buffer-substring (point-min) (point-max)))))
  120.         ((not (file-exists-p file)))
  121.         (t (insert-file-contents file)))
  122.       ;; Don't lose if no final newline.
  123.       (goto-char (point-max))
  124.       (or (eq (preceding-char) ?\n) (newline))
  125.       (goto-char (point-min))
  126.       ;; handle "\\\n" continuation lines
  127.       (while (not (eobp))
  128.         (end-of-line)
  129.         (if (= (preceding-char) ?\\)
  130.         (progn (delete-char -1) (delete-char 1) (insert ?\ ))
  131.             (forward-char 1)))
  132.       (goto-char (point-min))
  133.       (while (or (re-search-forward "^a\\(lias\\|\\)[ \t]+" nil t)
  134.              (re-search-forward "^g\\(roup\\|\\)[ \t]+" nil t))
  135.         (re-search-forward "[^ \t]+")
  136.         (let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
  137.            (start (progn (skip-chars-forward " \t") (point))))
  138.           (end-of-line)
  139.           (define-mail-alias
  140.         name
  141.         (buffer-substring start (point)))))
  142.       mail-aliases)
  143.       (if buffer (kill-buffer buffer))
  144.       (set-buffer obuf))))
  145.  
  146. ;; Always autoloadable in case the user wants to define aliases
  147. ;; interactively or in .emacs.
  148. ;;;###autoload
  149. (defun define-mail-alias (name definition)
  150.   "Define NAME as a mail alias that translates to DEFINITION.
  151. This means that sending a message to NAME will actually send to DEFINITION.
  152. DEFINITION can be one or more mail addresses separated by commas."
  153.   (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
  154.   ;; Read the defaults first, if we have not done so.
  155.   (if (eq mail-aliases t)
  156.       (progn
  157.     (setq mail-aliases nil)
  158.     (if (file-exists-p "~/.mailrc")
  159.         (build-mail-aliases))))
  160.   ;; strip garbage from front and end
  161.   (if (string-match "\\`[ \t\n,]+" definition)
  162.       (setq definition (substring definition (match-end 0))))
  163.   (if (string-match "[ \t\n,]+\\'" definition)
  164.       (setq definition (substring definition 0 (match-beginning 0))))
  165.   (let ((first (aref definition 0))
  166.     (last (aref definition (1- (length definition))))
  167.     tem)
  168.     (if (and (= first last) (memq first '(?\' ?\")))
  169.     ;; Strip quotation marks.
  170.     (setq definition (substring definition 1 (1- (length definition))))
  171.       ;; ~/.mailrc contains addresses separated by spaces.
  172.       ;; mailers should expect addresses separated by commas.
  173.       (while (setq tem (string-match "[^ \t,][ \t,]+" definition tem))
  174.     (if (= (match-end 0) (length definition))
  175.         (setq definition (substring definition 0 (1+ tem)))
  176.       (setq definition (concat (substring definition
  177.                           0 (1+ tem))
  178.                    ", "
  179.                    (substring definition (match-end 0))))
  180.       (setq tem (+ 3 tem)))))
  181.     (setq tem (assoc name mail-aliases))
  182.     (if tem
  183.     (rplacd tem definition)
  184.       (setq mail-aliases (cons (cons name definition) mail-aliases)))))
  185.  
  186. (provide 'mailalias)
  187.  
  188. ;;; mailalias.el ends here
  189.